perm filename SETLET.F4[MSS,LCS] blob sn#128715 filedate 1974-11-04 generic text, type T, neo UTF8
00100	C********  SUBRS.  SETLET, SETNUM, ACSHFT *********    
00200	
00300		SUBROUTINE SETLET
00400		DIMENSION R(8,100)
00500		COMMON/SCM/V(78),Y,LCNT,STAFF,JLIST(200),REND
00600		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(14),M,K,J,X,A,B
00650		1 /FLM/RPOS(2,300) /PTR/PWDS(250),ITEM,L,I,IX /XRN/RN(4000)
00800		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
00900		EQUIVALENCE (JF,JQ(4)),(R,RN(3001))
01000		M=1
01100		RPOS(1,1)=0
01200		DO 1 K=1,ITEM
01300		IF(FINDIT(K))GO TO 1
01400	C SKIPS NON-NOTES AND WRONG STAFF
01500		M=M+1
01600		RPOS(1,M)=RN(L+2)
01700	CC	RPOS(2,M)=L
01800	1	CONTINUE
01900		CALL SETNUM
02000		CALL SORT2(RPOS,M)
02100		K=2
02200	22	IF(RPOS(1,K).NE.RPOS(1,K-1))GO TO 2
02300		M=M-1
02400		DO 20 J=K,M
02500	20	RPOS(1,J)=RPOS(1,J+1)
02600	C  DELETES DOUBLE-STOPS - DOESN'T PUT NUM OVER 1ST NOTE.
02700		GO TO 22
02800	2	K=K+1
02900		IF(K.LT.M)GO TO 22
03000		DO 4 K=2,M
03100		JB=RHORZ(RPOS(1,K))
03200		CALL NOTWRT
03300		JF=JF+1
03400	4	IF(JF.EQ.10)JF=0
03500		CALL DPYOUT(3)
03600		CALL SETPOG(1)
03700		RPOS(1,M+1)=200
03800		J=1
03900		CALL TYPE
04000		REREAD F78F,V
04100		X=V(J)+1
04200		M=1
04300	3	K=X
04400		A=RPOS(1,K)
04500		B=RPOS(1,K+1)
04600		R(2,M)=A+(B-A)*(X-K)
04700		IF(R(4,M).NE.0)GO TO 5
04800		R(4,M)=V(J+1)
04900		J=J+2
05000		GO TO 6
05100	C IF P4≠0 TYPE ONLY 1 # FOR EACH ITEM. ALL ITEMS WILL BE AT VRT PS OF P4
05200	C TYPE Nn, Vert pos/Nn, Vert pos/  OR  Nn/Nn/ (if P4≠0)
05300	5	J=J+1
05400	6	M=M+1
05500		X=V(J)+1
05600		IF(X.GT.1)GO TO 3
05700	C CAN'T PUT LETTER AT POS. 0 *********
05800		END
05900	
06000		SUBROUTINE SETNUM
06100		DIMENSION SU(320)
06200		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
06300		COMMON/POSI/STF(8),JJB,POS/DPY/ST(4000),WDS(250),MEDIT,IGO
06400		EQUIVALENCE (JC,JQ(1)),(JF,JQ(4)),(RJE,RJQ(3)),(RJD,RJQ(2))
06500		1,(SU(1),ST(3600))
06600		CALL DPYSET(3,SU,320)
06700		CALL DPYBRT(6)
06800		JF=1
06900	CC	RA=ST(1)
07000	CC	RJD=R(3,1)
07100		POS=STF(JC+4)
07200		RJD=18.
07300		JA=5
07400		RJE=1
07500		END
07600	
07700		SUBROUTINE ACSHFT(RX)
07800		COMMON /XRN/RN(4000)
07900		COMMON /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA
08000		1,DBST,NFLG,IXX,ISEMI,IQT,F(50),IAMP,K,KN,M,MODE,IBLA
08100		DIMENSION R(8,100)
08200		EQUIVALENCE (R,RN(3001)),(A,F(1)),(B,F(2)),(X,F(4)),
08300		1(Y,F(5)),(Z,F(6)),(JD,F(7)),(RN1,F(8)),(RH,F(9))
08400		Z=0
08500		L=K-1
08600		M=L-ABS(RX)
08700		JD=1
08800		RN1=99
08900		Y=-.23
09000		IF(RX.LT.0)GO TO 1
09100		L=M
09200		M=K-1
09300		JD=-1
09400	1	DO 2 N=M,L,JD
09500	C  DOES IT HAVE AN ACCID?
09600		IF(AMOD(R(5,N),10.).EQ.0)GO TO 2
09700		A=R(6,N+1)
09800		B=R(6,N-1)
09900		IF(RN1.NE.99)GO TO 3
10000	C  IS THIS THE FIRST ACCID?
10100		RN1=R(4,N)
10200		GO TO 6
10300	3	RH=R(4,N)
10400		IF(ABS(RH-RN1).LT.5)GO TO 4
10500		RN1=RH
10600		IF(Y.GT.0)Z=Z+.04
10700	C STOPS OCT., ETC. ACCIS BEING MOVED TO LEFT.
10800		Y=-.23+Z
10900	6	IF(A.EQ.20.OR.B.EQ.20)Y=Z
11000	4	X=0
11100		IF(R(6,N).EQ.20)X=-.24
11200		IF(R(6,N).EQ.10)X=.24
11300		Y=Y+.23
11400		IF(X+Y.LT.1)GO TO 7
11500		RN1=RH
11600		Z=Z+.04
11700		Y=0
11800		IF(A.EQ.20.OR.B.EQ.20)Y=.23
11900	C  SO Y DOESN'T GET >1.
12000		Y=Y+Z
12100	7	X=X+Y
12200		IF(ABS(X-.04).LT..01)X=0
12300		IF(X.GE.0)GO TO 5
12400		Y=.23+Z
12500		X=Z
12600	5	R(5,N)=R(5,N)+X
12700	2	CONTINUE
12800		END